Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/source/units/ogware.pas

Pascal/Delphi Source File | 1994-04-03 | 15.6 KB | 804 lines

UNIT OGWare;

INTERFACE

{----------------------------------------------------------------------------}

CONST     ON          = TRUE;
          OFF         =FALSE;

          CapsLock    =   64;
          NumLoad     =   32;
          ScrollLock  =   16;

          CurNone     =    0;
          CurScore    =    1;
          CurBlock    =    2;

          Hexes       : ARRAY[0..$F] OF CHAR='0123456789ABCDEF';

          Black       =  0; Blue        =  1; Green       =  2;
          Cyan        =  3; Red         =  4; Magenta     =  5;
          Brown       =  6; LightGray   =  7; LightGrey   =  7;
          DarkGray    =  8; DarkGrey    =  8; LightBlue   =  9;
          LightGreen  = 10; LightCyan   = 11; LightRed    = 12;
          LightMagenta= 13; Yellow      = 14; White       = 15;

{----------------------------------------------------------------------------}

VAR       Audio,
          ButtonPress:BOOLEAN;
          ScanCode,
          wile,
          wiri,
          wibo,
          wito,
          scrX,
          scrY,
          fontsize,
          attribute,
          page:BYTE;
          Lpt1:WORD ABSOLUTE $0040:$0008;
          Lpt2:WORD ABSOLUTE $0040:$000A;
          Lpt3:WORD ABSOLUTE $0040:$000C;
          Lpt4:WORD ABSOLUTE $0040:$000E;

{----------------------------------------------------------------------------}

PROCEDURE AmigaPlay(lpt,size,delay:WORD; VAR snd);
PROCEDURE Beep(frequency,duration:WORD);
PROCEDURE Border(color:BYTE);
PROCEDURE ClearKeyBuffer;
PROCEDURE ClearLine(line:BYTE);
PROCEDURE ClearScreen;
PROCEDURE ClearWholeScreen;
PROCEDURE ClrScr;
PROCEDURE Color(fg,bg:BYTE);
PROCEDURE Cursor(mode:BYTE);
PROCEDURE DefineLed(led:BYTE; method:BOOLEAN);
PROCEDURE GetPos(VAR xpos,ypos:BYTE);
PROCEDURE GetVideoData;
PROCEDURE Intense(state:BOOLEAN);
PROCEDURE LowerCase(VAR stg:STRING);
PROCEDURE PcPlay(lpt,size,delay:WORD; VAR snd);
PROCEDURE ScrollDown(lines:BYTE);
PROCEDURE ScrollUp(lines:BYTE);
PROCEDURE SetPos(xpos,ypos:BYTE);
PROCEDURE SetWindow(xa,ya,xb,yb:BYTE);
PROCEDURE Silence;
PROCEDURE Speaker(frequency:WORD);
PROCEDURE ToggleLed(led:BYTE);
PROCEDURE UpperCase(VAR stg:STRING);
PROCEDURE UseDosFont(font:POINTER);
PROCEDURE Wait(ms:WORD);
PROCEDURE Wrt(line:STRING);
PROCEDURE WrtPos(xpos,ypos:BYTE; line:STRING);

{----------------------------------------------------------------------------}

FUNCTION  Byte2Hex(bte:BYTE):STRING;
FUNCTION  ByteSize(filename:STRING):LONGINT;
FUNCTION  CurrentKey:CHAR;
FUNCTION  Dec2Word(stg:STRING):WORD;
FUNCTION  Deg2Rad(deg:REAL):REAL;
FUNCTION  Factorize(VAR nr:WORD):WORD;
FUNCTION  Factorize2String(nr:WORD):STRING;
FUNCTION  File2Pointer(filename:STRING; VAR fl:POINTER):WORD;
FUNCTION  FileExists(filename:STRING):BOOLEAN;
FUNCTION  GetKey:CHAR;
FUNCTION  InString(small,big:STRING):BOOLEAN;
FUNCTION  InterruptVector(pntr:POINTER; itr:BYTE):POINTER;
FUNCTION  IsPrime(nr:WORD):BOOLEAN;
FUNCTION  KeyWaiting:BOOLEAN;
FUNCTION  Len(stg:STRING):BYTE;
FUNCTION  NextPrime(VAR nr:WORD):BOOLEAN; { TRUE & new nr value }
FUNCTION  Null(nr,len:INTEGER):STRING;
FUNCTION  Rad2Deg(rad:REAL):REAL;
FUNCTION  Word2Hex(wrd:WORD):STRING;
FUNCTION  X2Y(x,y:REAL):REAL;

{----------------------------------------------------------------------------}

IMPLEMENTATION

USES      Dos;

{****************************************************************************}

PROCEDURE AmigaPlay(lpt,size,delay:WORD; VAR snd); ASSEMBLER;
 ASM
     PUSH ds
     MOV  dx,Lpt
     MOV  bx,size
     LDS  si,snd
@lp: LODSB
     XOR  al,128
     OUT  dx,al
     { ms wait }
     MOV  ax,1000
     MUL  delay
     MOV  cx,dx
     MOV  dx,ax
     MOV  ah,$86
     INT  $15
     { ms wait }
     DEC  bx
     JNZ  @lp
     POP  ds
 END;

PROCEDURE Beep(frequency,duration:WORD); ASSEMBLER;
 ASM
     CMP  Audio,ON
     JNE  @qt
     IN   al,$61
     OR   al,003
     OUT  $61,al
     MOV  al,182
     OUT  $43,al
     MOV  ax,frequency
   { NOT  ax
     SHR  ax,002 }
     OUT  $42,al
     MOV  al,ah
     OUT  $42,al
     { ms wait }
     MOV  ax,1000
     MUL  duration
     MOV  cx,dx
     MOV  dx,ax
     MOV  ah,$86
     INT  $15
     { ms wait }
     IN   al,$61
     AND  al,252
     OUT  $61,al
@qt:
 END;

PROCEDURE Border(color:BYTE); ASSEMBLER;
 ASM
     MOV  ah,$0B
     MOV  bx,$000F
     AND  bl,color
     INT  $10
 END;

PROCEDURE ClearKeyBuffer; ASSEMBLER;
 ASM
     MOV  ax,$0040
     MOV  es,ax
     MOV  bx,es:[$001A]
     MOV  es:[$001C],bx
 END;

PROCEDURE ClearLine(line:BYTE); ASSEMBLER;
 ASM
     MOV  ah,$07
     MOV  al,$00
     MOV  bh,attribute
     MOV  cl,wile
     MOV  ch,line
     DEC  ch
     CMP  ch,wibo
     JA   @qt
     ADD  ch,wito
     MOV  dh,ch
     MOV  dl,wiri
     INT  $10
@qt:
 END;

PROCEDURE ClearScreen; ASSEMBLER;
 ASM
     MOV  ah,$07
     MOV  al,$00
     MOV  bh,attribute
     MOV  ch,wito
     MOV  cl,wile
     MOV  dh,wibo
     MOV  dl,wiri
     INT  $10
     MOV  ah,$02
     MOV  bh,page
     MOV  dl,wile
     MOV  dh,wito
     INT  $10
 END;

PROCEDURE ClearWholeScreen; ASSEMBLER;
 ASM
     MOV  ah,$07
     MOV  al,$00
     MOV  bh,attribute
     MOV  ch,0
     MOV  cl,0
     MOV  dh,scrY
     DEC  dh
     MOV  dl,scrX
     DEC  dl
     INT  $10
 END;

PROCEDURE ClrScr; ASSEMBLER;
 ASM
     MOV  ax,$0600
     MOV  bh,007
     MOV  cx,$0000
     MOV  dx,$FFFF
     INT  $10
     MOV  ah,002
     MOV  bh,000
     MOV  dx,$0000
     INT  $10
 END;

PROCEDURE Color(fg,bg:BYTE); ASSEMBLER;
 ASM
     MOV  al,bg
     SHL  al,4
     AND  fg,$0F
     ADD  al,fg
     MOV  attribute,al
 END;

PROCEDURE Cursor(mode:BYTE); ASSEMBLER;
 ASM
     MOV  ah,$01
     MOV  cl,fontsize
     DEC  cl
     AND  cl,00011111b
     CMP  mode,CurNone
     JE   @nn
     CMP  mode,CurBlock
     JE   @fl
     MOV  ch,cl
     DEC  ch
     AND  ch,000111111b
     JMP  @vd
@nn: MOV  ch,011000000b
     JMP  @vd
@fl: MOV  ch,000000000b
@vd: INT  $10
 END;

PROCEDURE DefineLed(led:BYTE; method:BOOLEAN); ASSEMBLER;
 ASM
     MOV  ax,$0040
     MOV  es,ax
     MOV  ah,led
     CMP  method,ON { if not turn on, then off }
     JE   @aa
     NOT  ah
     AND  es:[$0017],ah
     JMP  @nx
@aa: OR   es:[$0017],ah
@nx: MOV  ah,$01
     INT  $16
 END;

PROCEDURE GetPos(VAR xpos,ypos:BYTE); ASSEMBLER;
 ASM
     MOV  ah,$03
     MOV  bh,$00
     INT  $10
     INC  dl
     INC  dh
     SUB  dl,wile
     SUB  dh,wito
     LES  bx,xpos
     MOV  es:[bx],dl
     LES  bx,ypos
     MOV  es:[bx],dh
 END;

PROCEDURE GetVideoData; ASSEMBLER;
 ASM
     MOV  ah,$0F
     INT  $10
     MOV  page,bh
     MOV  scrX,AH
     DEC  AH
     MOV  wiri,ah
     MOV  wile,0
     MOV  ax,$0040
     MOV  es,ax
     MOV  al,es:[$0084]
     MOV  wibo,al
     MOV  wito,0
     INC  al
     MOV  scrY,al
     MOV  al,es:[$0086]
     MOV  fontsize,al
     MOV  ah,$08
     MOV  bh,page
     INT  $10
     MOV  attribute,ah
 END;

PROCEDURE Intense(state:BOOLEAN); ASSEMBLER;
 ASM
     MOV  ax,$1003
     MOV  bl,$00
     CMP  state,ON
     JE   @nx
     MOV  bl,$01
@nx: INT  $10
 END;

PROCEDURE LowerCase(VAR stg:STRING); ASSEMBLER;
 ASM
     LES  di,stg
     MOV  bl,es:[di]
     MOV  bh,$00
@lp: MOV  al,es:[bx+di]
     CMP  al,'A'
     JB   @nx
     CMP  al,'Z'
     JA   @na
     XOR  al,$20
@na: CMP  al,'Æ'
     JNE  @nb
     MOV  al,'æ'
@nb: CMP  al,'¥'
     JNE  @nc
     MOV  al,'¢'
@nc: CMP  al,'Å'
     JNE  @nx
     MOV  al,'å'
@nx: MOV  es:[bx+di],al
     DEC  bx
     CMP  bx,0
     JA   @lp
 END;

PROCEDURE PcPlay(lpt,size,delay:WORD; VAR snd); ASSEMBLER;
 ASM
     PUSH ds
     MOV  dx,Lpt
     MOV  bx,size
     LDS  si,snd
@lp: LODSB
     OUT  dx,al
     { ms wait }
     MOV  ax,1000
     MUL  delay
     MOV  cx,dx
     MOV  dx,ax
     MOV  ah,$86
     INT  $15
     { ms wait }
     DEC  bx
     JNZ  @lp
     POP  ds
 END;

PROCEDURE ScrollDown(lines:BYTE); ASSEMBLER;
 ASM
     MOV  ah,$07
     MOV  al,lines
     MOV  bh,attribute
     MOV  cl,wile
     MOV  ch,wito
     MOV  dl,wiri
     MOV  dh,wibo
     INT  $10
 END;

PROCEDURE ScrollUp(lines:BYTE); ASSEMBLER;
 ASM
     MOV  ah,$06
     MOV  al,lines
     MOV  bh,attribute
     MOV  cl,wile
     MOV  ch,wito
     MOV  dl,wiri
     MOV  dh,wibo
     INT  $10
 END;

PROCEDURE SetPos(xpos,ypos:BYTE); ASSEMBLER;
 ASM
     MOV  dl,xpos
     DEC  dl
     ADD  dl,wile
     CMP  dl,wiri
     JA   @qt
     MOV  dh,ypos
     DEC  dh
     ADD  dh,wito
     CMP  dh,wibo
     JA   @qt
     MOV  bh,page
     MOV  ah,$02
     INT  $10
@qt:
 END;

PROCEDURE SetWindow(xa,ya,xb,yb:BYTE); ASSEMBLER;
 ASM
     MOV  al,xa
     DEC  al
     CMP  al,0
     JL   @qt
     MOV  bl,ya
     DEC  bl
     CMP  bl,0
     JL  @qt
     MOV  cl,xb
     CMP  cl,scrX
     JA   @qt
     DEC  cl
     MOV  dl,yb
     CMP  dl,scrY
     JA   @qt
     DEC  dl
     MOV  wile,al
     MOV  wito,bl
     MOV  wiri,cl
     MOV  wibo,dl
@qt:
 END;

PROCEDURE Silence; ASSEMBLER;
 ASM
     IN   al,$61
     AND  al,252
     OUT  $61,al
 END;

PROCEDURE Speaker(frequency:WORD); ASSEMBLER;
 ASM
     IN   al,$61
     OR   al,$03
     OUT  $61,al
     MOV  al,182
     OUT  $43,al
     MOV  ax,frequency
     OUT  $42,al
     MOV  al,ah
     OUT  $42,al
 END;

PROCEDURE ToggleLed(led:BYTE); ASSEMBLER;
 ASM
     MOV  ax,$0040
     MOV  es,ax
     MOV  ah,led
     XOR  es:[$0017],ah
     MOV  ah,$01
     INT  $16
 END;

PROCEDURE UpperCase(VAR stg:STRING); ASSEMBLER;
 ASM
     LES  di,stg
     MOV  bl,es:[di]
     MOV  bh,$00
@lp: MOV  al,es:[bx+di]
     CMP  al,'a'
     JB   @nx
     CMP  al,'z'
     JA   @na
     XOR  al,$20
@na: CMP  al,'æ'
     JNE  @nb
     MOV  al,'Æ'
@nb: CMP  al,'¢'
     JNE  @nc
     MOV  al,'¥'
@nc: CMP  al,'å'
     JNE  @nx
     MOV  al,'Å'
@nx: MOV  es:[bx+di],al
     DEC  bx
     CMP  bx,0
     JA   @lp
 END;

PROCEDURE UseDosFont(font:POINTER);
 VAR o,s:WORD;
 BEGIN
   o:=Ofs(font^)+1; s:=Seg(font^);
   ASM
     PUSH bp
     MOV  ax,$1110
     MOV  es,s
     MOV  bp,o
     MOV  cx,$0100
     MOV  dx,$0000
     MOV  bh,es:[bp-1]
     MOV  bl,$00
     INT  $10
     POP  bp
   END;
 END;

PROCEDURE Wait(ms:WORD); ASSEMBLER;
 ASM
     MOV  ax,1000
     MUL  ms
     MOV  cx,dx
     MOV  dx,ax
     MOV  ah,$86
     INT  $15
 END;

PROCEDURE Wrt(line:STRING); ASSEMBLER;
 ASM
     MOV  ah,$03
     MOV  bh,$00
     INT  $10
     PUSH bp
     MOV  ax,$1300
     MOV  bh,page
     MOV  bl,attribute
     LES  bp,line
     INC  bp
     MOV  ch,0
     MOV  cl,wiri
     SUB  cl,dl
     INC  cl
     CMP  cl,es:[bp-1]
     JL   @nx
     MOV  cl,es:[bp-1]
@nx: INT  $10
     POP  bp
 END;

PROCEDURE WrtPos(xpos,ypos:BYTE; line:STRING); ASSEMBLER;
 ASM
     MOV  dl,xpos
     DEC  dl
     ADD  dl,wile
     CMP  dl,wiri
     JA   @qt
     MOV  dh,ypos
     DEC  dh
     ADD  dh,wito
     CMP  dh,wibo
     JA   @qt
     PUSH bp
     MOV  ax,$1300
     MOV  bh,page
     MOV  bl,attribute
     LES  bp,line
     INC  bp
     MOV  ch,0
     MOV  cl,wiri
     SUB  cl,dl
     INC  cl
     CMP  cl,es:[bp-1]
     JL   @nx
     MOV  cl,es:[bp-1]
@nx: INT  $10
     POP  bp
@qt:
 END;

{****************************************************************************}

FUNCTION  Byte2Hex(bte:BYTE):STRING;
 BEGIN
   Byte2Hex:='$'+Hexes[bte SHR 4]+Hexes[bte AND $F];
 END;

FUNCTION  ByteSize(filename:STRING):LONGINT;
 VAR fil:FILE OF BYTE;
 BEGIN
   Assign(fil,filename);
   Reset(fil);
   ByteSize:=FileSize(fil);
   Close(fil);
 END;

FUNCTION  CurrentKey:CHAR; ASSEMBLER; { with wait if no key }
 ASM
     MOV  ax,$0040
     MOV  es,ax
     MOV  ax,$0000
@wt: MOV  bx,es:[$001A]
     CMP  bx,es:[$001C]
     JZ   @wt
     MOV  ax,es:[bx]
     MOV  ScanCode,ah
 END;

FUNCTION  Dec2Word(stg:STRING):WORD;
 VAR tmp:WORD; t:BYTE;
 BEGIN
   tmp:=0;
   FOR t:=1 TO Len(stg) DO tmp:=tmp*10+ORD(stg[t])-48;
   Dec2Word:=tmp;
 END;

FUNCTION  Deg2Rad(deg:REAL):REAL;
 BEGIN
   Deg2Rad:=(deg*pi)/180;
 END;

FUNCTION  Factorize(VAR nr:WORD):WORD;
 VAR t:WORD;
 BEGIN
   FOR t:=2 TO (nr DIV 2+1) DO IF (nr/t=nr DIV t) THEN
    BEGIN
      Factorize:=t;
      nr:=nr DIV t;
      Exit;
    END;
   Factorize:=1;
 END;

FUNCTION  Factorize2String(nr:WORD):STRING;
 VAR t:WORD; s,r:STRING;
 BEGIN
   Str(nr,s); s:=s+'=';
   REPEAT
     t:=Factorize(nr);
     IF t>1 THEN
      BEGIN
        Str(t,r);
        s:=s+r+'*';
      END
     ELSE
      BEGIN
        Str(nr,r);
        s:=s+r;
      END;
   UNTIL t=1;
  Factorize2String:=s;
 END;

FUNCTION  File2Pointer(filename:STRING; VAR fl:POINTER):WORD;
 VAR size:LONGINT; fil:FILE;
 BEGIN
   IF NOT FileExists(filename) THEN
    BEGIN
      File2Pointer:=0;
      Exit;
    END;
   size:=ByteSize(filename);
   IF size>65530 THEN
    BEGIN
      File2Pointer:=0;
      Exit;
    END;
   GetMem(fl,size);
   File2Pointer:=size;
   Assign(fil,filename);
   Reset(fil,1);
   BlockRead(fil,fl^,size);
   Close(fil);
 END;

FUNCTION  FileExists(filename:STRING):BOOLEAN;
 VAR fil:FILE;
 BEGIN
   {$I-}
   Assign(fil,filename);
   FileMode:=0;
   Reset(fil);
   Close(fil);
   {$I+}
   FileExists:=(IOResult=0) AND (filename<>'');
 END;

FUNCTION  GetKey:CHAR; ASSEMBLER; { with wait if no key }
 ASM
     MOV  ax,$0040
     MOV  es,ax
@wt: MOV  bx,es:[$001A]
     CMP  bx,es:[$001C]
     JZ   @wt
     MOV  ax,es:[bx]
     MOV  ScanCode,AH
     ADD  bx,2
     CMP  bx,es:[$0082]
     JB   @nx           { buffer not at end }
     MOV  bx,es:[$0080]
@nx: MOV  es:[$001A],bx
 END;

FUNCTION  InString(small,big:STRING):BOOLEAN;
 VAR tmp:BYTE;
 BEGIN
   InString:=FALSE;
   IF Len(small)>Len(big) THEN Exit;
   UpperCase(small);
   UpperCase(big);
   FOR tmp:=1 TO (Len(big)-Len(small)+1) DO
   IF Copy(big,tmp,Len(small))=small THEN
    BEGIN
      InString:=TRUE;
      Exit;
    END;
 END;

FUNCTION  InterruptVector(pntr:POINTER; itr:BYTE):POINTER;
 BEGIN
   ASM CLI END;
   InterruptVector:=Ptr(MemW[0:itr*4+2],MemW[0:itr*4]);
   MemW[0:itr*4]:=Ofs(pntr^); MemW[0:itr*4+2]:=Seg(pntr^);
   ASM STI END;
 END;

FUNCTION  IsPrime(nr:WORD):BOOLEAN; ASSEMBLER;
 ASM
     MOV  si,2
     MOV  di,nr
     SHR  di,1
     MOV  bx,nr
@nn: MOV  dx,0
     MOV  ax,bx
     DIV  si
     CMP  dx,0
     JE   @ff
     INC  si
     CMP  si,di
     JB   @nn
     MOV  al,TRUE
     JMP  @qt
@ff: MOV  al,FALSE
@qt:
 END;

FUNCTION  KeyWaiting:BOOLEAN; ASSEMBLER;
 ASM
     MOV  ax,$0040
     MOV  es,ax
     MOV  al,FALSE
     MOV  bx,es:[$001A]
     CMP  bx,es:[$001C]
     JE   @qt
     MOV  al,TRUE
@qt:
 END;

FUNCTION  Len(stg:STRING):BYTE; ASSEMBLER;
 ASM
     LES  di,stg
     MOV  al,es:[di]
 END;

FUNCTION  NextPrime(VAR nr:WORD):BOOLEAN;
 VAR t:WORD;
 BEGIN
   FOR t:=nr+1 TO 65521 DO IF IsPrime(t) THEN
    BEGIN
      NextPrime:=TRUE;
      nr:=t;
      Exit;
    END;
   NextPrime:=FALSE;
 END;

FUNCTION  Null(nr,len:INTEGER):STRING;
 VAR s:STRING;
 BEGIN
   Str(nr:0,s);
   WHILE len>Length(s) DO s:='0'+s;
   Null:=s;
 END;

FUNCTION  Rad2Deg(rad:REAL):REAL;
 BEGIN
   Rad2Deg:=(180*rad)/pi;
 END;

FUNCTION  Word2Hex(wrd:WORD):STRING;
 BEGIN
   Word2Hex:='$'+Hexes[Hi(wrd) SHR  4]+Hexes[Hi(wrd) AND $F]+
                 Hexes[Lo(wrd) SHR  4]+Hexes[Lo(wrd) AND $F];
 END;


FUNCTION  X2Y(x,y:REAL):REAL;
 BEGIN
   X2Y:=Exp(y*Ln(x));
 END;

{****************************************************************************}

BEGIN
  Audio:=ON;
END.